home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / REGTLB.BAS < prev    next >
BASIC Source File  |  1997-06-14  |  8KB  |  271 lines
  1. Attribute VB_Name = "MRegTypeLib"
  2. Option Explicit
  3.  
  4. #Const ordRawBytes = 1
  5. #Const ordStrPtr = 2
  6. #Const ordTypeLib = 3
  7. #Const ordUnicode = ordStrPtr
  8. #If ordUnicode = ordRawBytes Then
  9. ' Receive string arguments as Byte arrays
  10. Private Declare Function LoadTypeLib Lib "oleaut32.dll" ( _
  11.     pFileName As Byte, pptlib As Object) As Long
  12. Private Declare Function RegisterTypeLib Lib "oleaut32.dll" ( _
  13.     ByVal ptlib As Object, szFullPath As Byte, _
  14.     szHelpFile As Byte) As Long
  15. #ElseIf ordUnicode = ordStrPtr Then
  16. ' Receive string arguments as pointers
  17. Private Declare Function LoadTypeLib Lib "oleaut32.dll" ( _
  18.     ByVal pFileName As Long, pptlib As Object) As Long
  19. Private Declare Function RegisterTypeLib Lib "oleaut32.dll" ( _
  20.     ByVal ptlib As Object, ByVal szFullPath As Long, _
  21.     ByVal szHelpFile As Long) As Long
  22. #ElseIf ordUnicode = ordTypeLib Then
  23.     ' No Declare needed!
  24. #End If
  25.  
  26. Const sEmpty = ""
  27.  
  28. Sub Main()
  29.     Dim fSilent As Boolean, fVerbose As Boolean
  30.     Dim sCmd As String, i As Integer, errOK As Long
  31.     Dim sSep As String, sToken As String, sLib As String
  32.     sCmd = Command$
  33.     If sCmd = sEmpty Then
  34.         sCmd = InputBox("Enter type library name and path: ")
  35.         If sCmd = sEmpty Then End
  36.     End If
  37.     sSep = " " & sTab
  38.     
  39.     ' Parse command line
  40.     sToken = GetToken(sCmd, sSep)
  41.     Do While sToken <> sEmpty
  42.         If InStr("/-", Left$(sToken, 1)) Then
  43.             Select Case UCase$(Mid$(sToken, 2, 1))
  44.             Case "S"
  45.                 fSilent = True
  46.             Case "V"
  47.                 fVerbose = True
  48.             Case Else
  49.                 ShowSyntax "Unknown option", fSilent
  50.                 End
  51.             End Select
  52.         Else
  53.             sLib = sToken
  54.         End If
  55.         sToken = GetToken(sEmpty, sSep)
  56.     Loop
  57.     
  58.     Dim sExt As String
  59.     Dim sBase As String, sFull As String
  60.     Dim iExt As Long, iBase As Long
  61.     ' Validate extension
  62.     iExt = GetExtPos(sLib)
  63.     iBase = GetBasePos(sLib)
  64.     sFull = sLib
  65.     sExt = Mid$(sFull, iExt)
  66.     sBase = Mid$(sFull, iBase, iExt - iBase)
  67.     Select Case UCase$(sExt)
  68.     Case sEmpty
  69.         ShowSyntax "No extension given", fSilent
  70.         End
  71.     Case ".TLB", ".OLB", ".DLL"
  72.     Case Else
  73.         ShowSyntax "Unknown extension", fSilent
  74.         End
  75.     End Select
  76.         
  77.     ' Register full name if given, or try to create 16/32 names
  78.     If sFull = sEmpty Then
  79.         ShowSyntax "File not found", fSilent
  80.     Else
  81.         errOK = RegTypelib(sFull)
  82.         If errOK Then
  83.             If Not fSilent Then MsgBox "Can't register type library: " & sLib
  84.         Else
  85.             If fVerbose Then MsgBox "Type library registered: " & sLib
  86.         End If
  87.     End If
  88.     
  89. End Sub
  90.  
  91. Function RegTypelib(sLib As String) As Long
  92. #If ordUnicode = ordRawBytes Then
  93.     Dim suLib() As Byte, errOK As Long, tlb As Object
  94.     ' Basic automatically translates strings to Unicode Byte arrays
  95.     ' but doesn't null-terminate, so you must do it yourself
  96.     suLib = sLib & vbNullChar
  97.     ' Pass first byte of array
  98.     errOK = LoadTypeLib(suLib(0), tlb)
  99.     If errOK = 0 Then errOK = RegisterTypeLib(tlb, suLib(0), 0)
  100.     RegTypelib = errOK
  101. #ElseIf ordUnicode = ordStrPtr Then
  102.     Dim errOK As Long, tlb As Object
  103.     ' Pass pointer to real (Unicode) string
  104.     errOK = LoadTypeLib(StrPtr(sLib), tlb)
  105.     If errOK = 0 Then errOK = RegisterTypeLib(tlb, StrPtr(sLib), 0)
  106.     RegTypelib = errOK
  107. #ElseIf ordUnicode = ordTypeLib Then
  108.     Dim tlb As ITypeLib
  109.     On Error GoTo FailRegTypeLib
  110.     ' Real HRESULT and real Unicode strings from type library
  111.     LoadTypeLib sLib, tlb
  112.     RegisterTypeLib tlb, sLib, sNullStr
  113.     Exit Function
  114. FailRegTypeLib:
  115.     MsgBox Err & ": " & Err.Description
  116.     RegTypelib = Err
  117. #End If
  118. End Function
  119.  
  120. Sub ShowSyntax(sErr As String, fSilent As Boolean)
  121.     If fSilent Then Exit Sub
  122.     Dim sMsg As String
  123.     Const sProg = "REGTLB32"
  124.     sMsg = sErr & sCr & sCr
  125.     sMsg = sMsg & _
  126.         sTab & "Syntax: " & sProg & " [/s] libname.ext" & sCr & sCr & _
  127.         sTab & "/s - Silent (don't show this message box)" & sCr & _
  128.         sTab & "/v - Verbose (report success)" & sCr & sCr
  129.     sMsg = sMsg & sProg & _
  130.         " will attempt to register both 16-bit and 32-bit libraries." & sCr & _
  131.         "For example, to register WIN16.TLB and WIN32.TLB, give any " & sCr & _
  132.         "of these commands: " & sCr & sCr
  133.     sMsg = sMsg & sTab & sProg & " WIN.TLB" & sCr
  134.     sMsg = sMsg & sTab & sProg & " WIN32.TLB" & sCr
  135.     sMsg = sMsg & sTab & sProg & " WIN16.TLB" & sCr
  136.     MsgBox sMsg
  137. End Sub
  138.  
  139. ' Some functions duplicated from other modules, but we don't want to use
  140. ' the Windows API type library in this program.
  141.  
  142. Function GetToken(sTarget As String, sSeps As String) As String
  143.     
  144.     ' Assume failure
  145.     GetToken = sEmpty
  146.     
  147.     ' Note that sSave and iStart must be static from call to call
  148.     ' If first call, make copy of string
  149.     Static sSave As String, iStart As Integer, cSave As Integer
  150.     
  151.     If sTarget <> sEmpty Then
  152.         iStart = 1
  153.         sSave = sTarget
  154.         cSave = Len(sSave)
  155.     Else
  156.         If sSave = sEmpty Then Exit Function
  157.     End If
  158.     
  159.     ' Find start of next token
  160.     Dim iNew As Integer
  161.     iNew = StrSpan(sSave, iStart, sSeps)
  162.     If iNew Then
  163.         ' Set position to start of token
  164.         iStart = iNew
  165.     Else
  166.         ' If no new token, return empty string
  167.         Exit Function
  168.     End If
  169.     
  170.     ' Find end of token
  171.     iNew = StrBreak(sSave, iStart, sSeps)
  172.     If iNew = 0 Then
  173.         ' If no end of token, set to end of string
  174.         iNew = cSave + 1
  175.     End If
  176.     
  177.     ' Cut token out of sTarget string
  178.     GetToken = Mid$(sSave, iStart, iNew - iStart)
  179.     ' Set new starting position
  180.     iStart = iNew
  181.  
  182. End Function
  183.  
  184. Function StrBreak(sTarget As String, ByVal iStart As Integer, sSeps As String) As Integer
  185.     
  186.     Dim cTarget As Integer
  187.     cTarget = Len(sTarget)
  188.    
  189.     ' Look for end of token (first character that is a separator)
  190.     Do While InStr(sSeps, Mid$(sTarget, iStart, 1)) = 0
  191.         If iStart > cTarget Then
  192.             StrBreak = 0
  193.             Exit Function
  194.         Else
  195.             iStart = iStart + 1
  196.         End If
  197.     Loop
  198.     StrBreak = iStart
  199.  
  200. End Function
  201.  
  202. Function StrSpan(sTarget As String, ByVal iStart As Integer, sSeps As String) As Integer
  203.     
  204.     Dim cTarget As Integer
  205.     cTarget = Len(sTarget)
  206.     ' Look for start of token (character that isn't a separator)
  207.     Do While InStr(sSeps, Mid$(sTarget, iStart, 1))
  208.         If iStart > cTarget Then
  209.             StrSpan = 0
  210.             Exit Function
  211.         Else
  212.             iStart = iStart + 1
  213.         End If
  214.     Loop
  215.     StrSpan = iStart
  216.  
  217. End Function
  218.  
  219. Function GetExtPos(sSpec As String) As Integer
  220.     Dim iLast As Integer, iExt As Integer
  221.     iLast = Len(sSpec)
  222.     
  223.     ' Assume no extension
  224.     GetExtPos = iLast + 1
  225.     ' Parse backward to find extension or base
  226.     For iExt = iLast + 1 To 1 Step -1
  227.         Select Case Mid$(sSpec, iExt, 1)
  228.         Case "."
  229.             ' First . from right is extension start
  230.             GetExtPos = iExt
  231.             Exit Function
  232.         Case "\", ":"
  233.             ' First \ or : from right is base start, so no extension
  234.             Exit Function
  235.         End Select
  236.     Next
  237.     ' Fall through means no extension
  238. End Function
  239.  
  240. Function GetBasePos(sFile As String) As Integer
  241.     Dim iLast As Integer, iBase As Integer
  242.     iLast = Len(sFile)
  243.     
  244.     ' Assume no directory
  245.     GetBasePos = 1
  246.     
  247.     ' Parse backward to find base
  248.     For iBase = iLast + 1 To 1 Step -1
  249.         Select Case Mid$(sFile, iBase, 1)
  250.         Case "\", ":"
  251.             ' First \ or : from right is base start
  252.             GetBasePos = iBase + 1
  253.             Exit For
  254.         End Select
  255.     Next
  256. End Function
  257.  
  258. ' Defined in type library, but we must define for others
  259. #If ordUnicode <> ordTypeLib Then
  260. Property Get sCr() As String
  261.     sCr = Chr$(13)
  262. End Property
  263.  
  264. Property Get sTab() As String
  265.     sTab = Chr$(9)
  266. End Property
  267. #End If
  268.  
  269.  
  270.  
  271.